home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / xscm.lha / xscm / xmtest.scm < prev    next >
Encoding:
Text File  |  1992-08-29  |  5.7 KB  |  213 lines
  1. ; $Header: /home/campbell/Languages/Scheme/scm/x-scm/RCS/xmtest.scm,v 1.2 1992/07/03 14:04:35 campbell Beta $
  2. ;
  3. ; Random test functions to exercise Motif and Xt interface
  4. ;
  5. (require 'stdio)
  6. (require (in-vicinity (library-vicinity) "x11.scm"))
  7. (require (in-vicinity (library-vicinity) "xt.scm"))
  8. (require (in-vicinity (library-vicinity) "xm.scm"))
  9. (require (in-vicinity (library-vicinity) "xevent.scm"))
  10. (require (in-vicinity (library-vicinity) "xmsubs.scm"))
  11.  
  12. (define (say x) (display x) (newline) (force-output))
  13.  
  14. (define (go)
  15.   (xt:realize-widget top-level)
  16.   (xt:main-loop))
  17.  
  18. (define top-level
  19.   (if (defined? vs:top-level)
  20.       (xt:app-create-shell "shell" "Shell"
  21.                xt:application-shell
  22.                (xt:display vs:top-level))
  23.       (xt:initialize "shell" "Shell")))
  24.  
  25. (xt:set-values top-level xm:n-allow-shell-resize #t)
  26.  
  27.  
  28. (define (stringlist->xmstringvector sl)
  29.   (let* ((sv (list->vector sl))
  30.      (len (vector-length sv)))
  31.     (do ((i 0 (1+ i)))
  32.     ((= i len) sv)
  33.       (vector-set! sv i (xm:string-create (vector-ref sv i))))))
  34.  
  35. (define listvector
  36.   (stringlist->xmstringvector
  37.    '(
  38.      "thing one"
  39.      "thing two"
  40.      "and another thing"
  41.      "this is a longer item"
  42.      "this is another longer item"
  43.      "I need to have lots of items"
  44.      "in my list"
  45.      "so I can test out the scrolling"
  46.      "functions"
  47.      )))
  48.  
  49. (define (list-demo)
  50.   (make-list top-level))
  51.  
  52. (define (make-list parent)
  53.   (let ((w
  54.      (xt:create-managed-widget
  55.       "list"
  56.       xm:list
  57.       parent
  58.       xm:n-height 200
  59.       xm:n-items (xm:vector->xmstringtable listvector)
  60.       xm:n-item-count (vector-length listvector)
  61.       xm:n-selection-policy xm:multiple-select)))
  62.     (xt:add-callback
  63.      w xm:n-multiple-selection-callback
  64.      (lambda (w)
  65.        (let* ((n (xt:get-value w xm:n-selected-item-count xt:integer))
  66.           (items (xt:get-value w xm:n-selected-items xt:xmstringtable n))
  67.           (itemvector (xm:xmstringtable->vector items)))
  68.      (printf "There are %d selected items\\n" n)
  69.      (do ((i 0 (1+ i)))
  70.          ((= i n) #t)
  71.        (let ((s (xm:string-get-first-segment (vector-ref itemvector i))))
  72.          (printf "Item %d is \"%s\"\\n" i s)
  73.          (force-output))))))
  74.     w))
  75.  
  76. (define (scroll-demo)
  77.   (let* ((sw
  78.       (xt:create-managed-widget
  79.        "slist"
  80.        xm:scrolled-window
  81.        top-level
  82.        xm:n-height 400
  83.        xm:n-width 300
  84.        xm:n-scrolling-policy xm:automatic))
  85.      (ww
  86.       (make-list sw)))
  87.     (xt:set-values
  88.      sw
  89.      xm:n-work-window ww)))
  90.  
  91. (define (menu-demo)
  92.   (let* ((bb (xt:create-managed-widget
  93.           "bboard" xm:bulletin-board top-level
  94.           xt:n-width 200
  95.           xt:n-height 200))
  96.      (menu (make-popup-menu
  97.         "Press here, honey"
  98.         bb
  99.         `("Button 1" ,(lambda (w) (say "Button 1")))
  100.         `("Button 2" ,(lambda (w) (say "Button 2")))
  101.         `("Button 3" ,(lambda (w) (say "Button 3"))) )))
  102.     (xt:add-event-handler
  103.      bb
  104.      x:button-press-mask
  105.      0
  106.      (lambda (widget event)
  107.        (xm:menu-position menu event)
  108.        (xt:manage-children menu)))
  109.     menu))
  110.  
  111. (define (event-demo)
  112.   (let* ((pw (xt:create-managed-widget
  113.           "pane" xm:paned-window top-level))
  114.      (rc (xt:create-managed-widget
  115.           "rc" xm:row-column pw))
  116.      (da (xt:create-managed-widget
  117.           "da" xm:drawing-area pw
  118.           xm:n-width  200
  119.           xm:n-height 200))
  120.      (mt (xt:create-managed-widget
  121.           "mt" xm:label rc)))
  122.     (xt:add-event-handler
  123.      da x:leave-window-mask 0
  124.      (lambda args
  125.        (display "leave window: ")
  126.        (display args)
  127.        (newline)))
  128.     (xt:add-event-handler
  129.      da x:pointer-motion-mask 0
  130.      (lambda (w e)
  131.        (let ((x (x:get-event-field e x:motion-event:x))
  132.          (y (x:get-event-field e x:motion-event:y)))
  133.      (xm:wprintf mt "x: %d y: %d" x y))))))
  134.  
  135. (define (xm:wprintf w f . args)
  136.   (let* ((buf (make-string 80 #\space))
  137.      (l (apply sprintf buf (cons f args)))
  138.      (s (substring buf 0 l))
  139.      (label (xm:string-create s)))
  140.     (xt:set-values w xm:n-label-string label)))
  141.  
  142. ; (menu-bar name parent ("label1" menu1)
  143.  
  144. (define (menu-bar name parent)
  145.   (let ((menubar (xt:create-managed-widget
  146.           name xm:row-column parent
  147.           xm:n-row-column-type xm:menu-bar)))
  148.     (make-pulldown-menu
  149.      "Folder" menubar
  150.      `("Open" ,(lambda (w) (say "Open")))
  151.      `("Create"  ,(lambda (w) (say "Create")))
  152.      `("Browse" ,(lambda (w) (say "Browse"))))
  153.     (make-pulldown-menu
  154.      "View" menubar
  155.      `("Open" ,(lambda (w) (say "Open")))
  156.      `("Create"  ,(lambda (w) (say "Create")))
  157.      `("Browse" ,(lambda (w) (say "Browse"))))
  158.     (make-pulldown-menu
  159.      "Help" menubar
  160.      `("About" ,(lambda (w) (say "Open")))
  161.      `("Help"  ,(lambda (w) (say "Create"))))
  162.     menubar))
  163.  
  164.  
  165. (define (menubar-demo)
  166.   (let ((bb (xt:create-managed-widget
  167.          "bboard" xm:bulletin-board top-level
  168.          xm:n-margin-height 0
  169.          xm:n-margin-width 0)))
  170.     (menu-bar "menubar" bb)))
  171.  
  172. (define drawing-area 0)
  173.  
  174. (define (draw-demo)
  175.   (let* ((da (xt:create-managed-widget
  176.           "drawing-area" xm:drawing-area top-level
  177.           xt:n-height 200 xt:n-width 200))
  178.      (disp (xt:display da))
  179.      (window (begin (xt:realize-widget top-level) (xt:window da)))
  180.      (xgc1 (x:create-gc disp () x:gc-foreground 0 x:gc-background 1))
  181.      (xgc2 (x:create-gc disp () x:gc-foreground 1 x:gc-background 0)))
  182.     (xt:add-event-handler
  183.      da x:exposure-mask 0
  184.      (lambda (w e)
  185.        (let ((x (xt:get-value w xt:n-width xt:integer))
  186.          (y (xt:get-value w xt:n-height xt:integer)))
  187.      (x:fill-rectangle disp window xgc1 0 0 x y)
  188.      (x:draw-points disp window xgc2 0
  189.             '(10 . 10)
  190.             '(11 . 11)
  191.             '(12 . 12)
  192.             '(13 . 13)
  193.             '(14 . 14)
  194.             '(15 . 14)
  195.             '(16 . 14)
  196.             '(17 . 14)
  197.             '(18 . 14)
  198.             '(19 . 14)
  199.             '(20 . 14))
  200.      )))
  201.     (xt:add-callback
  202.      da xm:n-resize-callback
  203.      (lambda (w)
  204.        (let ((x (xt:get-value w xt:n-width xt:integer))
  205.          (y (xt:get-value w xt:n-height xt:integer)))
  206.      (printf "width=%d, height=%d\\n" x y)
  207.        )))
  208.     (x:clear-area disp window 0 0 0 0 #t)
  209.     (set! drawing-area da)
  210.     (x:flush (xt:display da))
  211.     ))
  212.  
  213.